home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / str.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-13  |  8.1 KB  |  335 lines
  1. /*
  2.  *
  3.  * s t r . c                -- Strings management
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: ??????
  22.  * Last file update: 13-May-1996 22:42
  23.  */
  24.  
  25. #include <ctype.h>
  26. #include "stk.h"
  27.  
  28. static char bad_string_message[] = "comparing string: bad string";
  29.  
  30. static int stringcomp(SCM s1, SCM s2)
  31. {
  32.   register int l1, l2;
  33.   register char *str1, *str2;
  34.  
  35.   if (NSTRINGP(s1)) Err(bad_string_message, s1); 
  36.   if (NSTRINGP(s2)) Err(bad_string_message, s2);
  37.  
  38.   for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
  39.        l1 && l2;
  40.        l1--, str1++, l2--, str2++)
  41.     if (*str1 != *str2) return (*str1 - *str2);
  42.   
  43.   /* l1 == 0 || l2 == 0 */
  44.   return l1 ? +1 : (l2 ? -1 : 0);
  45. }
  46.  
  47.  
  48. static int stringcompi(SCM s1, SCM s2)
  49. {
  50.   register int l1, l2;
  51.   register char *str1, *str2;
  52.  
  53.   if (NSTRINGP(s1)) Err(bad_string_message, s1);
  54.   if (NSTRINGP(s2)) Err(bad_string_message, s2);
  55.  
  56.   for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
  57.        l1 && l2;
  58.        l1--, str1++, l2--, str2++)
  59.     if (tolower(*str1) != tolower(*str2))
  60.     return (tolower(*str1) - tolower(*str2));
  61.  
  62.   /* l1 == 0 || l2 == 0 */
  63.   return l1 ? +1 : (l2 ? -1 : 0);
  64. }
  65.  
  66. SCM STk_makestrg(int len, char *init)
  67. {
  68.   SCM  z;
  69.  
  70.   STk_disallow_sigint();
  71.   NEWCELL(z, tc_string);
  72.  
  73.   z->storage_as.string.dim  = len;
  74.   z->storage_as.string.data = (char *) must_malloc(len+1); 
  75.   z->storage_as.string.data[len] = 0;
  76.  
  77.   if (init) memcpy(z->storage_as.string.data, init, len);
  78.   STk_allow_sigint();
  79.  
  80.   return z;
  81. }
  82.  
  83.  
  84. /**** Section 6.7 ****/
  85.  
  86. PRIMITIVE STk_stringp(SCM obj)
  87. {
  88.   return STRINGP(obj) ? Truth: Ntruth;
  89. }
  90.  
  91. PRIMITIVE STk_make_string(SCM len, SCM init_char)
  92. {
  93.   long k;
  94.   SCM z;
  95.  
  96.   if ((k=STk_integer_value(len)) < 0) Err("make-string: bad string length", len);
  97.  
  98.   z = STk_makestrg(k, NULL);
  99.       
  100.   if (init_char != UNBOUND) {
  101.     if (CHARP(init_char)) {
  102.       char c = CHAR(init_char);
  103.       int j;
  104.  
  105.       for(j=0 ;j<k; j++) z->storage_as.string.data[j] = c;
  106.     }
  107.     else
  108.       Err("make-string: initializing char not valid", init_char); }
  109.   return z;
  110. }
  111.  
  112. PRIMITIVE STk_lstring(SCM l, int len)
  113. {
  114.   int j;
  115.   SCM tmp, z;
  116.  
  117.   if (len < 0) Err("string: bad list", l);
  118.   z = STk_makestrg(len, NULL);
  119.  
  120.   /* copy element in newly allocated string */
  121.   for (j=0; j < len; j++, l=CDR(l)) {
  122.     tmp = CAR(l);
  123.     if (NCHARP(tmp)) Err("string: bad element", tmp);
  124.     CHARS(z)[j] = CHAR(tmp);
  125.   }
  126.   return z;
  127. }
  128.  
  129. PRIMITIVE STk_string_length(SCM str)
  130. {
  131.   if (NSTRINGP(str)) Err("string-length: not a string", str);
  132.   return STk_makeinteger(STRSIZE(str));
  133. }
  134.  
  135. PRIMITIVE STk_string_ref(SCM str, SCM index)
  136. {
  137.   long k;
  138.  
  139.   if (NSTRINGP(str))                Err("string-ref: not a string", str);
  140.   if ((k=STk_integer_value(index)) < 0) Err("string-ref: bad index", index);
  141.  
  142.   if (k >= STRSIZE(str)) 
  143.     Err("string-ref: index out of bounds", index);
  144.   return STk_makechar(CHARS(str)[k]);
  145. }
  146.  
  147. PRIMITIVE STk_string_set(SCM str, SCM index, SCM value)
  148. {
  149.   long k;
  150.  
  151.   if (NSTRINGP(str))                Err("string-set!: not a string", str); 
  152.   if ((k=STk_integer_value(index)) < 0) Err("string-set!: bad index", index); 
  153.   
  154.   if (k >= STRSIZE(str)) 
  155.     Err("string-set!: index out of bounds", index);
  156.     
  157.   if (NCHARP(value)) Err("string-set!: value is not a char", value);
  158.     
  159.   CHARS(str)[k] = CHAR(value);
  160.   return UNDEFINED;
  161. }
  162.  
  163. PRIMITIVE STk_streq   (SCM s1,SCM s2){return (stringcomp(s1,s2)==0)? Truth: Ntruth;}
  164. PRIMITIVE STk_strless (SCM s1,SCM s2){return (stringcomp(s1,s2)<0) ? Truth: Ntruth;}
  165. PRIMITIVE STk_strgt   (SCM s1,SCM s2){return (stringcomp(s1,s2)>0) ? Truth: Ntruth;}
  166. PRIMITIVE STk_strlesse(SCM s1,SCM s2){return (stringcomp(s1,s2)<=0)? Truth: Ntruth;}
  167. PRIMITIVE STk_strgte  (SCM s1,SCM s2){return (stringcomp(s1,s2)>=0)? Truth: Ntruth;}
  168.  
  169. PRIMITIVE STk_streqi   (SCM s1,SCM s2){return (stringcompi(s1,s2)==0)?Truth:Ntruth;}
  170. PRIMITIVE STk_strlessi (SCM s1,SCM s2){return (stringcompi(s1,s2)<0) ?Truth:Ntruth;}
  171. PRIMITIVE STk_strgti   (SCM s1,SCM s2){return (stringcompi(s1,s2)>0) ?Truth:Ntruth;}
  172. PRIMITIVE STk_strlessei(SCM s1,SCM s2){return (stringcompi(s1,s2)<=0)?Truth:Ntruth;}
  173. PRIMITIVE STk_strgtei  (SCM s1,SCM s2){return (stringcompi(s1,s2)>=0)?Truth:Ntruth;}
  174.  
  175. PRIMITIVE STk_substring(SCM string, SCM start, SCM end)
  176. {
  177.   char msg[] = "substring: not an integer";
  178.   int from, to;
  179.  
  180.   if (NSTRINGP(string)) Err("substring: not a string", string);
  181.  
  182.   if ((from=STk_integer_value(start))==LONG_MIN) Err(msg ,start);
  183.   if ((to=STk_integer_value(end)) == LONG_MIN)   Err(msg ,end);
  184.  
  185.   if (0 <= from && from <= to && to <= STRSIZE(string))
  186.     return STk_makestrg(to - from, CHARS(string)+from);
  187.  
  188.   Err("substring: bad bounds", Cons(start, end));
  189. }
  190.  
  191. PRIMITIVE STk_string_append(SCM l, int len)
  192. {
  193.   int i, total=0;
  194.   SCM z, tmp = l;
  195.   char *p;
  196.   
  197.   /* Compute total length of resulting string */
  198.   for (i = 0; i < len; i++) {
  199.     if (NSTRINGP(CAR(tmp)))
  200.       Err("string-append: bad string", CAR(tmp));
  201.     total += STRSIZE(CAR(tmp));
  202.     tmp = CDR(tmp);
  203.   }
  204.  
  205.   /* Allocate result */
  206.   z = STk_makestrg(total, NULL);
  207.   p = CHARS(z);
  208.   
  209.   /* copy strings */
  210.   for (i=0; i < len; i++) {
  211.     memcpy(p, CHARS(CAR(l)), STRSIZE(CAR(l)));
  212.     p += STRSIZE(CAR(l));
  213.     l = CDR(l);
  214.   }
  215.   return z;
  216. }
  217.  
  218. PRIMITIVE STk_string2list(SCM str)
  219. {
  220.   int j, len;
  221.   SCM tmp, z = NIL;
  222.  
  223.   if (NSTRINGP(str)) Err("string->list: not a string", str);
  224.   len = STRSIZE(str);
  225.  
  226.   for (j=0; j<len; j++) {
  227.     if (j == 0)
  228.       tmp = z = Cons(STk_makechar(CHARS(str)[j]), NIL);
  229.     else 
  230.       tmp = CDR(tmp) = Cons(STk_makechar(CHARS(str)[j]), NIL);
  231.   }
  232.   return z;
  233. }
  234.  
  235. PRIMITIVE STk_list2string(SCM l)
  236. {
  237.   int j=0, len = STk_llength(l);
  238.   SCM z;
  239.  
  240.   if (len < 0) Err("list->string: bad list", l);
  241.   z = STk_makestrg(len, NULL);
  242.   for ( ; NNULLP(l); l=CDR(l)) {
  243.     if (NCHARP(CAR(l))) Err("list->string: not a character", CAR(l));
  244.     CHARS(z)[j++] = CHAR(CAR(l));
  245.   }
  246.   return z;
  247. }
  248.  
  249. PRIMITIVE STk_string_copy(SCM str)
  250. {
  251.   if (NSTRINGP(str)) Err("string-copy: not a string", str);
  252.   return STk_makestring(CHARS(str));
  253. }
  254.  
  255. PRIMITIVE STk_string_fill(SCM str, SCM c)
  256. {
  257.   int len, i;
  258.   char c_char;
  259.  
  260.   if (NSTRINGP(str)) Err("string-fill: not a string", str);
  261.   if (NCHARP(c))     Err("string-fill: not a char", c);
  262.  
  263.   len = STRSIZE(str);
  264.   c_char = CHAR(c);
  265.  
  266.   for (i = 0; i < len; i++)
  267.     CHARS(str)[i] = c_char;
  268.   return UNDEFINED;
  269. }
  270.  
  271.  
  272. /*
  273.  * 
  274.  * STk bonus
  275.  *
  276.  */
  277.  
  278. static char *Memmem(char *s1, int l1, char *s2, int l2)
  279. {
  280.   if (l2 == 0) return s1;
  281.  
  282.   for ( ; l1 >= l2 ; s1++, l1--)
  283.     if (memcmp(s1, s2, l2) == 0) return s1;
  284.  
  285.   return NULL;
  286. }
  287.  
  288. PRIMITIVE STk_string_findp(SCM s1, SCM s2)
  289. {
  290.   char msg[] = "string-find?: bad string";
  291.  
  292.   if (NSTRINGP(s1)) Err(msg,s1);
  293.   if (NSTRINGP(s2)) Err(msg,s2);
  294.   
  295.   return Memmem(CHARS(s2), STRSIZE(s2), CHARS(s1), STRSIZE(s1)) ? Truth: Ntruth;
  296. }
  297.  
  298. PRIMITIVE STk_string_index(SCM s1, SCM s2)
  299. {
  300.   char *p, msg[] = "string-index: bad string";
  301.  
  302.   if (NSTRINGP(s1)) Err(msg,s1);
  303.   if (NSTRINGP(s2)) Err(msg,s2);
  304.  
  305.   p = Memmem(CHARS(s2), STRSIZE(s2), CHARS(s1), STRSIZE(s1));
  306.   
  307.   return p? STk_makeinteger(p - CHARS(s2)) : Ntruth;
  308. }
  309.  
  310.  
  311.  
  312. PRIMITIVE STk_string_lower(SCM s)
  313. {
  314.   SCM z;
  315.   register char *p, *q;
  316.  
  317.   if (NSTRINGP(s)) Err("string-lower: not a string", s);
  318.   z = STk_makestrg(strlen(CHARS(s)), NULL);
  319.  
  320.   for (p=CHARS(s), q=CHARS(z); *p; p++, q++) *q = tolower(*p);
  321.   return z;
  322. }
  323.  
  324. PRIMITIVE STk_string_upper(SCM s)
  325. {
  326.   SCM z;
  327.   register char *p, *q;
  328.  
  329.   if (NSTRINGP(s)) Err("string-upper: not a string", s);
  330.   z = STk_makestrg(strlen(CHARS(s)), NULL);
  331.  
  332.   for (p=CHARS(s), q=CHARS(z); *p; p++, q++) *q = toupper(*p);
  333.   return z;
  334. }
  335.